
;;(load "bindings.lisp")

;; =============================================================================
;; C code generator context
(defstruct c-codegen-context
  (indent nil :type fixnum)
  (types nil :type hash-table)
  (functions nil :type hash-table)
  (keywords nil :type hash-table))

;; =============================================================================
;; prints C type
(defun print-c-type (context type)
  (let ((v-type (gethash type (c-codegen-context-types context))))
    (unless v-type (error "such a type has not been registered"))
    (format t v-type)))

;; =============================================================================
;; emits block part: function or keyword
(defun emit-function-or-keyword-expr (context expr)
  (let ((f-name (car expr))
	(f-args (cdr expr))
	func-assoc
	keyword-assoc)
    (setf func-assoc (gethash f-name (c-codegen-context-functions context)))
    (setf keyword-assoc (gethash f-name (c-codegen-context-keywords context)))
    (cond
      ;; function call
      (func-assoc
       (format t "~a(" func-assoc)
       (let (next)
	 (dolist (call-arg f-args)
	   (if next
	       (format t ", ")
	       (setf next t))
	   (emit-expr context call-arg)))
       (format t ");~%"))
      ;; in-block keyword usage
      (keyword-assoc (funcall keyword-assoc context f-args))
      (t (error "no such function or keyword")))))

;; =============================================================================
;; emits block of C code
(defun emit-c-block (context block)
  (format t "~%{~%")
  (dolist (block-element block)
    (emit-function-or-keyword-expr context block-element))
  (format t "}~%"))

;; =============================================================================
;; emits elementary expression part
(defun emit-expr (context expr)
  (cond
    ;; number, likely a constant
    ((numberp expr) (format t "~a" expr))
    ;; symbol, likely a variable
    ((symbolp expr) (format t "~a" expr))
    ;; string
    ((stringp expr) (format t "\"~a\"" expr))
    ;; unknown entity
    (t (error "emit-expr is not implemented to handle such kind of expressions"))
    ))

;; =============================================================================
;; emitter function
(defun emit-c-code (context type arg)
  (check-type context c-codegen-context)
  (cond
    ;; include
    ((eq type 'include-local) (format t "#include \"~a\"~%" arg))
    ((eq type 'include-global) (format t "#include <~a>~%" arg))
    ;; function
    ((eq type 'type)
     (print-c-type context arg)
     (format t " "))
    ((eq type 'func-name) (emit-c-code context 'name arg))
    ((eq type 'name) (format t "~a" arg))
    ((eq type 'func-args)
     (format t "(")
     (let ((first-arg t))
       (dolist (func-arg arg)
         (if first-arg
             (setf first-arg nil)
             (format t ", "))
         (emit-c-code context 'type (car func-arg))
         (emit-c-code context 'name (cadr func-arg)))
       (format t ")")))
    ((eq type 'block) (emit-c-block context arg))
    (t (error "not implemented!"))))

;; =============================================================================
;; code emitter
;; TODO: move emit-c-code toplev-related things here!!!
(defun process-c-expr (context expr)
  (let ((func-id (car expr)) (func-body (cdr expr)))
    ;; introduce lexical binding to et-test function
    (flet ((emit (item-type item-expr) (emit-c-code context item-type item-expr)))
      ;; cond expansion that processes the given expression
      (gen-cond-expansion
       func-id				; bound function id
       func-body			; bound function body

       ;; functions
       (include-local (name)
                      (emit 'include-local name))

       (include-global (name)
                       (emit 'include-global name))
       
       (func (type-and-name arglist &rest body)
	     (emit 'type (car type-and-name))
	     (emit 'func-name (cadr type-and-name))
	     (emit 'func-args arglist)
	     (emit 'block body)
	     )

       ))))

;; =============================================================================
;; test data
(defparameter *sample-code*
  '(
    (include-global "stdio.h")
    (func (int main) ((int argc) (const-char-pp argv))
     (fputs "hello, world!" stderr)
     ;;(fcloseall)
     (getchar)
     (return 0))
    ))

(defun assoc-strs (hashtable arglist)
  (check-type hashtable hash-table)
  (dolist (arg arglist)
    (let (src assoc)
      (cond
	((consp arg)
	 (setf src (car arg))
	 (setf assoc (cadr arg))
	 (check-type src symbol)
	 (check-type assoc string))
	((symbolp arg)
	 (setf src arg)
	 (setf assoc (format nil "~a" src)))
	(t (error "invalid arg-assoc construction")))
      (setf (gethash src hashtable) assoc))))

;; =============================================================================
;; makes test C codegen context
(defun make-test-c-codegen-context ()
  (let ((types (make-hash-table))
	(functions (make-hash-table))
	(keywords (make-hash-table)))
    ;; fill types
    (assoc-strs types
		'(int
		  (const-char-pp "const char **")))

    ;; fill functions
    (assoc-strs functions
		'(fputs getchar iosfwd))

    ;; fill keywords
    (setf (gethash 'return keywords) (lambda (context expr)
				       (format t "return ")
				       (emit-expr context (car expr))
				       (format t ";~%")))
    
    ;; create context
    (make-c-codegen-context
     :indent 0
     :types types
     :functions functions
     :keywords keywords)))

;; =============================================================================
;; test function
(defun test-process-c-expr ()
  (process-c-expr
   (make-test-c-codegen-context)
   '(func (int main) () (return 0)))

  (let ((context (make-test-c-codegen-context)))
    (dolist (expr *sample-code*)
      (process-c-expr context expr)))
  )


;; =============================================================================
;; another approach
;; =============================================================================


;;(load "bindings.lisp")


(defmacro gen-c-expr-expansion (func-id func-body &rest mapping-list)
  `(cond
    ,@(loop for i in mapping-list collect
	    `((eq ',(car i) ,func-id)
	      (static-bindings ,func-body ,(cadr i)
	       ;; form
	       (prn-hint context ',(car i) 'begin)
	       ,@(cddr i)
	       (prn-hint context ',(car i) 'end)
	       )))
    (t (error "unexpected func-id"))
    ))

(defun prn (context &rest args)
  (check-type context c-codegen-context)
  (dolist (arg args)
    (check-type arg (or standard-char string))
    (format t "~a" arg)))

(defun prn-hint (context scope-id location)
  (cond
    ;; scope beginning
    ((and (or (eq scope-id 'block))
	  (eq location 'begin))
     (prn context #\Newline))
    ;; scope end
    ((and (or (eq scope-id 'include-local) (eq scope-id 'include-global) (eq scope-id 'block))
	  (eq location 'end))
     (prn context #\Newline))))

(defun printable-c-type-name (context type-sym)
  (let ((v-type (gethash type-sym (c-codegen-context-types context))))
    (unless v-type (error "such a type has not been registered"))
    ;; return v-type
    v-type))

(defun printable-c-func-name (context func-name-sym)
  ;; FIXME: more correct transformation?
  (format nil "~a" func-name-sym))

(defun printable-c-arg-name (context func-name-sym)
  ;; FIXME: more correct transformation?
  (format nil "~a" func-name-sym))

(defun process-c-expr-block (context expr)
  ;; FIXME: prn-hint exposed here
  (prn-hint context 'block 'begin)

  (prn context "{}")

  ;; FIXME: prn-hint exposed here
  (prn-hint context 'block 'end))

(defun process-c-expr-func-arglist (context expr)
  ;; FIXME: prn-hint exposed here
  (prn-hint context 'func-arglist 'begin)
  
  (prn context "(")
  (let ((first-arg t))
    (dolist (func-arg expr)
      (if first-arg
	  (setf first-arg nil)
	  (prn context ", "))

      (prn-hint context 'arg 'begin)

      (prn context
	   (printable-c-type-name context (car func-arg))
	   " "
	   (printable-c-arg-name context (cadr func-arg)))
      
      (prn-hint context 'arg 'end)))
  (prn context ")")

  ;; FIXME: prn-hint exposed here
  (prn-hint context 'func-arglist 'end))

(defun process-c-expr-toplev (context expr)
  (let ((func-id (car expr)) (func-body (cdr expr)))
    ;; cond expansion that processes the given expression
    (gen-c-expr-expansion
     func-id				; bound function id
     func-body				; bound function body

     ;; functions

     ;; #include "header"
     (include-local (name)
		    (prn context "#include \"" name "\""))

     ;; #include <header>
     (include-global (name)
		     (prn context "#include <" name ">"))

     ;; function declaration, e.g. int foo(int arg) { return arg+5; }
     (func (type-and-name arglist &rest body)
	   (prn context
		;; type name
		(printable-c-type-name context (car type-and-name))
		" "
		(printable-c-func-name context (cadr type-and-name))
		)

	   ;; function's arguments list
	   (process-c-expr-func-arglist context arglist)

	   ;; if this is a forward decl - prn ; otherwise prn all the block
	   (if (null body)
	       (prn ";")
	       (process-c-expr-block context body)))

     )))


;; =============================================================================
;; test
(defun make-tst-cctx ()
  (make-c-codegen-context
     :indent 0
     :types (make-hash-table)
     :functions (make-hash-table)
     :keywords (make-hash-table)))

(defun tst33 ()

  ;; test 1
  (process-c-expr-toplev
   (make-test-c-codegen-context)
   '(func (int main) ((int argc) (const-char-pp argv)) (return 0))
   ;;'(include-local "asd")
   )
  )